home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / S / SCOOPS / INTERF.S < prev    next >
Encoding:
Text File  |  1993-06-15  |  7.2 KB  |  204 lines
  1. ;* INTERF.S
  2. ;************************************************************************
  3. ;*                                    *
  4. ;*        PC Scheme/Geneva 4.00 Scheme code            *
  5. ;*                                    *
  6. ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT        *
  7. ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva    *
  8. ;*                                    *
  9. ;*----------------------------------------------------------------------*
  10. ;*                                    *
  11. ;*        Scoops: Class definition, DEFINE-CLASS            *
  12. ;*                                    *
  13. ;*----------------------------------------------------------------------*
  14. ;*                                    *
  15. ;* Created by: Amitabh Srivastava        Date: 1986        *
  16. ;* Revision history:                            *
  17. ;* - 18 Jun 92:    Renaissance (Borland Compilers, ...)            *
  18. ;*                                    *
  19. ;*                    ``In nomine omnipotentii dei''    *
  20. ;************************************************************************
  21.  
  22. ;
  23.  
  24. (macro define-class
  25.   (lambda (e)
  26.     (let ((name (cadr e))(classvars '()) (instvars '()) (mixins '())
  27.           (options '())(allvars '())(method-values '())(inits '()))
  28.       (letrec
  29.         ((chk-class-def
  30.            (lambda (deflist)
  31.              (if deflist
  32.                  (begin
  33.                   (cond ((eq? (caar deflist) 'classvars)
  34.                          (set! classvars (cdar deflist)))
  35.                         ((eq? (caar deflist) 'instvars)
  36.                          (set! instvars (cdar deflist)))
  37.                         ((eq? (caar deflist) 'mixins)
  38.                          (set! mixins (cdar deflist)))
  39.                         ((eq? (caar deflist) 'options)
  40.                          (set! options (cdar deflist)))
  41.                         (else (error-handler (caar deflist) 0 '())))
  42.                   (chk-class-def (cdr deflist)))
  43.                  (update-allvars))))
  44.  
  45.          (update-allvars
  46.           (lambda ()
  47.             (set! allvars
  48.                   (append (mapcar (lambda (a) (if (atom? a) a (car a)))
  49.                                   classvars)
  50.                           (mapcar (lambda (a) (if (atom? a) a (car a)))
  51.                                   instvars)))))
  52.  
  53.  
  54.          (chk-option
  55.            (lambda (opt-list)
  56.              (let loop ((opl opt-list)(meths '()))
  57.                (if opl
  58.                    (loop
  59.                     (cdr opl)
  60.                     (cond ((eq? (caar opl) 'gettable-variables)
  61.                            (append (generate-get (cdar opl)) meths))
  62.                           ((eq? (caar opl) 'settable-variables)
  63.                            (append (generate-set (cdar opl)) meths))
  64.                           ((eq? (caar opl) 'inittable-variables)
  65.                            (set! inits (cdar opl)) meths)
  66.                           (else (error-handler (car opl) 1 '()))))
  67.                    meths))))
  68.  
  69.        (chk-cvs
  70.          (lambda (list-var)
  71.            (mapcar
  72.              (lambda (a)
  73.                (if (atom? a)
  74.                    (list a '#!unassigned)
  75.                    a))
  76.              list-var)))
  77.  
  78.        (chk-init
  79.          (lambda (v-form)
  80.            (if (memq (car v-form) inits)
  81.                `(,(car v-form)
  82.                  (APPLY-IF (memq ',(car v-form) '%sc-init-vals)
  83.                            (lambda (a) (cadr a))
  84.                            ,(cadr v-form)))
  85.                v-form)))
  86.  
  87.        (chk-ivs
  88.          (lambda (list-var)
  89.            (mapcar
  90.              (lambda (var)
  91.                (chk-init
  92.                   (cond ((atom? var) (list var '#!unassigned))
  93.                         ((not-active? (cadr var)) var)
  94.                         (else (active-val (car var) (cadr var))))))
  95.              list-var)))
  96.  
  97.        (not-active?
  98.          (lambda (a)
  99.            (or (atom? a)
  100.                (not (eq? (car a) 'active)))))
  101.  
  102.        (empty-slot? not)
  103.  
  104.        (active-val
  105.          (lambda (var active-form)
  106.            (let loop ((var var)(active-form active-form)
  107.                       (getfns '())(setfns '%sc-val))
  108.              (if (not-active? (cadr active-form))
  109.                  (create-active
  110.                   var
  111.                   (if (empty-slot? (caddr active-form))
  112.                       getfns
  113.                       (cons (caddr active-form) getfns))
  114.                   (list 'set! var
  115.                         (if (empty-slot? (cadddr active-form))
  116.                             setfns
  117.                             (list (cadddr active-form) setfns)))
  118.                   (cadr active-form))
  119.                  (loop
  120.                   var
  121.                   (cadr active-form)
  122.                   (if (empty-slot? (caddr active-form))
  123.                       getfns
  124.                       (cons (caddr active-form) getfns))
  125.                   (if (empty-slot? (cadddr active-form))
  126.                       setfns
  127.                       (list (cadddr active-form) setfns)))))))
  128.  
  129.        (create-active
  130.          (lambda (var getfns setfns localstate)
  131.           (set! method-values
  132.            (cons `(CONS ',(concat "GET-" var)
  133.                         ,(%sc-expand
  134.                           `(LAMBDA ()
  135.                              (LET ((SELF (FLUID SELF)))
  136.                                ,(expand-getfns var getfns)))))
  137.                  (cons `(CONS ',(concat "SET-" var)
  138.                               ,(%sc-expand
  139.                                 `(LAMBDA (%SC-VAL)
  140.                                    (LET ((SELF (FLUID SELF)))
  141.                                      ,setfns))))
  142.                        method-values)))
  143.           (list var localstate)))
  144.  
  145.        (expand-getfns
  146.          (lambda (var getfns)
  147.            (let loop ((var var)(gets getfns)(exp-form var))
  148.              (if gets
  149.                  (loop
  150.                   var
  151.                   (cdr gets)
  152.                   (list (car gets) exp-form))
  153.                  exp-form))))
  154.  
  155.        (concat
  156.          (lambda (str sym)
  157.            (string->symbol (string-append str (symbol->string sym)))))
  158.  
  159.        (generate-get
  160.          (lambda (getlist)
  161.            (mapcar
  162.              (lambda (a)
  163.                `(CONS ',(concat "GET-" a)
  164.                       ,(%sc-expand
  165.                         `(LAMBDA ()
  166.                            (LET ((SELF (FLUID SELF)))
  167.                              ,a)))))
  168.              getlist)))
  169.  
  170.        (generate-set
  171.          (lambda (setlist)
  172.            (mapcar
  173.              (lambda (a)
  174.                `(CONS ',(concat "SET-" a)
  175.                       ,(%sc-expand
  176.                         `(LAMBDA (%sc-val)
  177.                            ; Berichtigt 02.07.87 Lutz Euler:
  178.                            (LET ((SELF (FLUID SELF)))
  179.                              (SET! ,a %sc-val))))))
  180.              setlist)))
  181.  
  182.      )
  183.  
  184.         (chk-class-def (cddr e))
  185.         (set! method-values
  186.               (chk-option
  187.                   (mapcar (lambda (a) (if (atom? a) (cons a allvars) a))
  188.                           options)))
  189.         `(DEFINE ,name
  190.                  (%SC-MAKE-CLASS
  191.                   ',name
  192.                   ',(if classvars
  193.                         (chk-cvs classvars)
  194.                         #F)
  195.                   ',(if instvars
  196.                         (chk-ivs instvars)
  197.                         #F)
  198.                   ',mixins
  199.                   ,(if method-values
  200.                        (cons 'list method-values)
  201.                        '())
  202.                     ))))))
  203.  
  204.